# Usage: rptodp.tcl rpvariant.var dpvariant.map

package require Iexpect
package require Itcl

proc wrong {message} {
	puts "Error: $message"
}

proc warn {message} {
	puts "Warning: $message"
}

proc resolve {fileSpec dirSpec} {
	set origDirSpec $dirSpec
	regsub -all "\\\\" $fileSpec "/" fileSpec
	if {[regexp -nocase "^\[a-z\]+:/" $fileSpec]} {
		if [file exists $fileSpec] {return $fileSpec}
		set fileSpec [string range $fileSpec [string first "/" $fileSpec] end]
	}
	regsub -all "\\\\" $dirSpec "/" dirSpec
	while 1 {
		if [string equal [string index $fileSpec 0] "/"] {
			if {![regexp -nocase "^\[a-z\]+:" $dirSpec drive]} {
				if [file exists $fileSpec] {return $fileSpec}
			} elseif [file exists "$drive$fileSpec"] {return "$drive$fileSpec"}
		} elseif [file exists "$dirSpec/$fileSpec"] {return "$dirSpec/$fileSpec"}
		# Remove directories from dirSpec from back to front.
		if {[set dirEnd [string last "/" $dirSpec]] == -1} {
			error "File \"$fileSpec\" not found as part of directory \"$origDirSpec\""
			return $fileSpec
		}
		set dirSpec [string range $dirSpec 0 [expr $dirEnd - 1]]
	}
}

proc checkDesignation {type location destination designation isReciprocal} {
	# The first test is to see if the '/' is actually part of the name, which is highly unlikely.
	if {(![info exists ::moves($destination/$designation,$type)]) || ([lsearch $::moves($destination/$designation,$type) $location] == -1)} {
		# The second test is to see if the location is part of the destination's designation list. This is the most likely case.
		if {(![info exists ::moves($destination,$designation)]) || ([lsearch $::moves($destination,$designation) $location] == -1)} {
			# The third test (split up in two) is to see if it's a reciprocal situation, as in the case of MX (the Loeb9 reduced attack move across straits). Not very common.
			if {![info exists ::moves($destination,$type)]} {
				warn "Unidirectional $::unit($type) movement from $location to $destination/$designation"
			} elseif {!$isReciprocal || ([lsearch $::moves($destination,$type) "$location/$designation"] == -1)} {
				# The fourth test is simply to see if one simply forgot to specify the designation. Not a common mistake.
				if {[lsearch $::moves($destination,$type) $location] == -1} {
					warn "The $::unit($type) movement between $location and $destination only to $designation in one direction"
				} else {
					warn "Unidirectional $::unit($type) movement from $location to $destination/$designation"
				}
			}
		}
	}
}

proc hasLower {word} {
	regexp "\[a-z\]" $word
}

proc replaceCapitals {word} {
	# If the word only consists of capitals, leave it as it is.
	if {![hasLower $word]} {return $word}
	# Precede all capitals, except the initial, with a '+'.
	return [string toupper "[string index $word 0][regsub -all "\[A-Z\]" [string range $word 1 end] "+&"]"]
}

proc findAlternative {name desc master} {
	global alternatives territoryName
	if [info exists territoryName($name)] {return $name}
	foreach {space alternativeList} [array get alternatives] {
		if [string equal -nocase $name $territoryName($space)] {return $space}
		foreach alternative $alternativeList {
			if [string equal -nocase $name $alternative] {return $space}
		}
	}
	warn "$desc $name for $master is not defined in the map data"
	return $name
}

proc findMain {space desc master} {
	global territoryName moves
	if {[regexp "^(.+)/(.+)$" $space dummy name designation] || [regexp "^(.+)\[(\](.+)\[)\]$" $space dummy name designation]} {
		set name [findAlternative $name $desc $master]
		if {![string equal $designation "MX"] && ![info exists moves($name,$designation)] && [info exists territoryName($name)]} {
			warn "$designation is not a valid designation for space $name; ignored."
			return $name
		} else {
			return "$name/$designation"
		}
	} else {
		findAlternative $space $desc $master
	}
}

array set direction {
	SC south
	WC west
	EC east
	NC north
}

array set unit {
	MV army
	XC fleet
}

itcl::class Table {
	constructor {format} {
		# Mark each variable element with %s. Insert fixed elements as is. Put spaces between each element.
		set iFormat $format
		foreach element $iFormat {if [string equal $element "%s"] {incr iNrVariables}}
		for {set idx 0} {$idx < $iNrVariables} {incr idx} {lappend iWidths 0}
	}

	method addRow {args} {
		if {[llength $args] != $iNrVariables} {error "Expecting $iNrVariables in table row"}
		for {set idx 0} {$idx < $iNrVariables} {incr idx} {
			if {[set length [string length [lindex $args $idx]]] > [lindex $iWidths $idx]} {
				set iWidths [lreplace $iWidths $idx $idx $length]
			}
		}
		lappend iRows $args
	}

	method write {fileId} {
		writeTable $fileId
		
		# Reinitialize.
		set iRows {}
		set iWidths {}
		for {set idx 0} {$idx < $iNrVariables} {incr idx} {lappend iWidths 0}
	}

	protected method writeTable {fileId} {
		# Strip off any empty columns at the end.
		set stripped 0
		for {set lastIdx [expr [llength $iWidths] - 1]; set last [expr [llength $iFormat] - 1]} {$lastIdx >= 0} {incr lastIdx -1; incr last -1} {
			if {![lindex $iWidths $lastIdx] && [string equal [lindex $iFormat $last] "%s"]} {set stripped 1} else {break}
		}
		if {$last < 0} {return}
		if $stripped {
			set rows $iRows
			set iRows {}
			foreach row $rows {
				lappend iRows [lrange $row 0 $lastIdx]
			}
		}

		# Determine the tabular format.
		set format {}
		set idx 0
		foreach element [lrange $iFormat 0 [expr $last -1]] {
			if [string equal $element "%s"] {
				if [set width [lindex $iWidths $idx]] {
					lappend format "%-${width}s"
				} else {
					set rows $iRows
					set iRows {}
					foreach row $rows {
						lappend iRows [lreplace $row $idx $idx]
					}
				}
				incr idx
			} else {
				lappend format $element
			}
		}
		lappend format [lindex $iFormat end]

		# Write out.
		foreach row $iRows {
			puts $fileId [string trimright [eval format [list $format] $row]]
		}
	}

	method getWidths {} {return $iWidths}

	variable iFormat
	variable iNrVariables 0
	variable iWidths {}
	variable iRows {}
}

# Check arguments.

if {[llength $argv] < 2} {
	puts "Error: 2 arguments required, the name of a RealPolitik .var file and the name of the resulting .map file."
	puts "Usage: rptodp.tcl rpvariant.var dpvariant.map"
	exit
}

# Parsing the RealPolitik variant file.

iexpect::Expect I -file [lindex $argv 0] -white

set varFile [resolve [lindex $argv 0] [pwd]]
set variantDir [file dirname $varFile]

set variantName [file rootname $varFile]

I expect line "^Name: ?" {
	set variantName [string trimright [I get unchecked]]
	I continue
} "^MapData: ?(\[^ \]+)" {
	set mapFile [resolve [I get match 1] $variantDir]
	I continue
} "^Countries: ?(\[^ \]+)" {
	set cntFile [resolve [I get match 1] $variantDir]
	I continue
} "^Game: ?(\[^ \]+)" {
	set gamFile [resolve [I get match 1] $variantDir]
	I continue
} "^Build: ?(\[^ \]+)" {
	switch -- [string tolower [I get match 1]] "standard" {
	} "chaos" {
		lappend rules "RULE BUILD_ANY"
	} "aberration" {
		lappend rules "RULE REMOTE_BUILDS"
	} default {
		error "Build style unknown: \"[I get match 1]\""
	}
	I continue
} "^Centers: ?(\[^ \]+)" {
	if {[I get match 1] != 0} {
		lappend rules "VICTORY [I get match 1]"
	}
	I continue
} default {
	I continue
}

itcl::delete object I

puts "Variant name: \"$variantName\""
#if [info exists rules] {
#	puts "Rules:"
#	foreach rule $rules { puts "  $rule" }
#}
#if [info exists mapFile] { puts "Map data: \"$mapFile\"" }
#if [info exists cntFile] { puts "Countries: \"$cntFile\"" }
#if [info exists gamFile] { puts "Game: \"$gamFile\"" }

# Parsing the RealPolitik map file.

iexpect::Expect I -file $mapFile -white

I expect line "^#" {
	I continue
} "^(\[^,\]+), ?(\[^ \]+) (\[^ \]+)" {
	set terrain [I get match 2]
	set primary [string index $terrain 0]
	if {[string length $terrain] > 1} {
		if {[string length $terrain] > 2} {
			warn "Terrain type $terrain contains more than 2 characters in \"[I get output]\""
		}
		if {[string first [string index $terrain 1] "wv"] == -1} {
			warn "Unrecognized terrain subtype [string index $terrain 1] in \"[I get output]\""
		}
		if {[string is lower $primary] && ([string first $primary "lx"] == -1)} {
			warn "Unrecognized primary terrain type $primary in \"[I get output]\""
		}
	} elseif {[string is lower $primary] && ([string first $primary "lwxv"] == -1)} {
		warn "Unrecognized terrain type $primary in \"[I get output]\""
	}
	set location [string toupper [I get match 3]]
	set territoryName($location) [I get match 1]
	set territoryType($location) $terrain
	set alternatives($location) "[I get match 3][I get unchecked]"
	I continue
} "^-1$" {
} "^$" {
	I continue
} default {
	warn "Unrecognized map data: \"[I get unmatched]\""
	I continue
}

I expect line "^#" {
	I continue
} "^(\[^-\]+)-(\[a-zA-Z\]{2}):" {
	set location [string toupper [I get match 1]]
	set moving [string toupper [I get match 2]]
	if {[lsearch "MV XC EC NC SC WC MX" $moving] == -1} {
		warn "Unrecognized movement $moving in \"[I get output]\""
	} else {
		set location [findAlternative $location "Location" "$location-$moving"]
		# We will determine the correct names for all destinations after recording all locations, 
		# since at this point we still don't know about multicoasts.
		eval lappend moves($location,$moving) [string toupper [I get unchecked]]
	}
	I continue
} "^-1$" {
} "^$" {
	I continue
} default {
	warn "Unrecognized map data: \"[I get unmatched]\""
	I continue
}

# Determine names of destinations
foreach {movement destinations} [array get moves] {
	set destinationList {}
	foreach destination $destinations {
		lappend destinationList [findMain $destination "Destination" [regsub "," $movement "-"]]
	}
	set moves($movement) $destinationList
}

itcl::delete object I

# Parsing the RealPolitik countries file.

iexpect::Expect I -file $cntFile -white

I expect line "^#" {
	I continue
} "^\[0-9\]+$" {
	# Version and number of players
	I continue
} "^(\[^ \]+) (\[^ \]+) (\[^ \]) " {
	# Power name, adjective and initial
	lappend powers [set power [replaceCapitals [I get match 1]]]
	set adjective($power) [replaceCapitals [I get match 2]]
	set initial($power) [string toupper [I get match 3]]
	set inpower($initial($power)) $power
	if [string equal $initial($power) M] {
		warn "The initial M of power $power is normally reserved for the Master; please change"
	}
	I continue
} "^$" {
	I continue
} default {
	warn "Unrecognized cnt data: \"[I get unmatched]\""
	I continue
}

itcl::delete object I

# Parsing the RealPolitik game file.

iexpect::Expect I -file $gamFile -white -nocase

I expect before "^#" {
	I continue
} "^$" {
	I continue
}

# Version
I expect line default {}
# Variant Name
I expect line default {}
# Title Bar Name
I expect line default {}
# Season
I expect line "^spring (-?\[0-9\]+)$" {
	lappend rules "BEGIN SPRING [I get match 1] MOVEMENT"
} "^fall (-?\[0-9\]+)$" {
	lappend rules "BEGIN FALL [I get match 1] MOVEMENT"
} "^winter (-?\[0-9\]+)$" {
	lappend rules "BEGIN WINTER [I get match 1] ADJUSTMENTS"
} default {
	warn "Unrecognized season in gam file: \"[I get output]\""
}
# Number of adjustments
I expect line "^-?\[0-9\]+$" {} default {
	warn "Unrecognized number of adjustments in gam file: \"[I get output]\""
}
# Number of players
I expect line "^\[0-9\]+$" {
	if {[I get match] != [llength $powers]} {
		warn "Not the expected number of powers in gam file: [I get match 1] instead of [llength $powers]"
	}
} default {
	warn "Unrecognized number of players in gam file: \"[I get output]\""
}

set idx 0
set power {}
I expect line "^-?\[0-9\]+$" {
	if {$idx <= [llength $powers]} {
		set power [lindex $powers $idx]
		incr idx 
		I continue
	}
} "^(\[af\] \[^ \]+ ?)+$" {
	if {!$idx} {
		warn "Adjustment for initial power not found."
		set power [lindex $powers $idx]
		incr idx
	}
	set units($power) [string toupper [I get match]]
	I continue
} default {
	if {!$idx} {
		warn "Adjustment for initial power not found."
		set power [lindex $powers $idx]
		incr idx
	}
	set centers($power) [string toupper [I get output]]
	I continue
}

itcl::delete object I

# Outputting the DPjudge map file.

set g [open [lindex $argv 1] w]

puts $g "# DPjudge map data for $variantName" 

puts $g "\n# Locations\n"

Table locationTable "%s = %s %s"
foreach location [lsort [array names territoryName]] {
	locationTable addRow $territoryName($location) [lindex $alternatives($location) 0] [lrange $alternatives($location) 1 end]
	foreach ucoast [lsort [array names direction]] {
		if {![info exists moves($location,$ucoast)]} continue
		set lcoast [string tolower $ucoast]
		set name $territoryName($location)
		set alters {}
		foreach alternative $alternatives($location) {
			if [hasLower $alternative] {set coast $lcoast} else {set coast $ucoast}
			lappend alters "$alternative/$coast" "$alternative\($coast\)"
		}
		regsub -all " " $name "+" name
		if [hasLower $name] {set coast $lcoast} else {set coast $ucoast}
		lappend alters "$name/$coast" "$name\($coast\)"
		locationTable addRow "$territoryName($location) \($direction($ucoast) coast\)" [lindex $alters 0] [lrange $alters 1 end]
	}
}
locationTable write $g
itcl::delete object locationTable

puts $g "\n# Geography\n"

Table geographyTable "%s %s ABUTS %s"
foreach location [lsort [array names territoryType]] {

	set landMovement {}
	if [info exists moves($location,MV)] {
		foreach destination $moves($location,MV) {
			if {[set idx [string last "/" $destination]] >= 1} {
				set designation [string range $destination [expr $idx + 1] end]
				set destination [string range $destination 0 [expr $idx - 1]]
				if {![string equal $designation "MX"]} {
					warn "Unexpected destination designation $destination/$designation in army movement for $location"
					lappend landMovement "$destination/$designation"
				} else {
					lappend landMovement "~$destination"
				}
				checkDesignation MV $location $destination $designation 1
			} else {
				lappend landMovement $destination
				if {(![info exists moves($destination,MV)]) || ([lsearch $moves($destination,MV) $location] == -1)} {
					warn "Unidirectional army movement from $location to $destination"
				}
			}
		}
	}
	set waterMovement {}
	if [info exists moves($location,XC)] {
		foreach destination $moves($location,XC) {
			lappend waterMovement $destination
			if {[set idx [string last "/" $destination]] >= 1} {
				set designation [string range $destination [expr $idx + 1] end]
				set destination [string range $destination 0 [expr $idx - 1]]
				if {[lsearch [array names direction] $designation] == -1} {
					warn "Unexpected destination designation $destination/$designation in fleet movement for $location"
					checkDesignation XC $location $destination $designation 1
				} else {
					checkDesignation XC $location $destination $designation 0
				}
			} else {
				if {(![info exists moves($destination,XC)]) || ([lsearch $moves($destination,XC) $location] == -1)} {
					warn "Unidirectional fleet movement from $location to $destination"
				}
			}
		}
	}
	if [info exists moves($location,MX)] {
		foreach destination $moves($location,MX) {
			lappend landMovement "~$destination"
			checkDesignation MV $location $destination MX 1
		}
	}

	set terrain SHUT
	set isLand 0
	set terrainType [string index $territoryType($location) end]
	if {[string first $terrainType "wv"] != -1} {
		if {[string equal $terrainType "v"]} {
			# Type ice. SHUT in Fall and winter, WATER in Spring.
			if {[lsearch $rules "RULE HIBERNATE"] == -1} {lappend rules "RULE HIBERNATE"}
			lappend rules "IN SPRING: WATER $location"
		} elseif {[string length $territoryType($location)] > 1} {
			set terrain PORT
		} else {
			set terrain WATER
		}
	} else {
		if {[string length $territoryType($location)] > 1} {
			warn "Terrain type \"$territoryType($location)\" of location $location consists of more than two characters, but is not a port."
		} 
		if {![string is lower $terrainType] || ([string first $terrainType "lx"]) != -1} {
			set isLand 1
			set terrain LAND
		} else {
			warn "Unrecognized terrain type \"$terrainType\" of location $location. Treating as SHUT."
		}
	}

	set located $location
	foreach coast [lsort [array names direction]] {
		if [info exists moves($location,$coast)] {
			set located [string tolower $location]
			foreach destination $moves($location,$coast) {
				if {[lsearch $waterMovement $destination] == -1} {lappend waterMovement $destination}
				if {[set idx [string last "/" $destination]] >= 1} {
					set designation [string range $destination [expr $idx + 1] end]
					set destination [string range $destination 0 [expr $idx - 1]]
					if {[lsearch [array names direction] $designation] == -1} {
						warn "Unexpected destination designation $destination/$designation in fleet movement for $location/$coast"
						checkDesignation XC $location/$coast $destination $designation 1
					} else {
						checkDesignation XC $location/$coast $destination $designation 0
					}
				} else {
					if {(![info exists moves($destination,XC)]) || ([lsearch $moves($destination,XC) $location/$coast] == -1)} {
						warn "Unidirectional fleet movement from $location/$coast to $destination"
					}
				}
			}
		
			# A dictionary sort is case-insensitive.
			geographyTable addRow COAST "$location/$coast" [lsort $moves($location,$coast)]
		}
	}

	if [llength $landMovement] {
		if [llength $waterMovement] {
			if $isLand {set terrain COAST}
			set movement $waterMovement
			foreach destination $waterMovement {
				if {[set idx [string last "/" $destination]] >= 1} {
					set destination [string range $destination 0 [expr $idx - 1]]
				}
				if {[set idx [lsearch $landMovement $destination]] >= 0} {
					set landMovement [lreplace $landMovement $idx $idx] 
				}
			}
			eval lappend movement [string tolower $landMovement]
		} else {
			if {!$isLand} {
				warn "Expected XC for movement through water or port, got MV."
			}
			set movement $landMovement
		}
	} elseif [llength $waterMovement] {
		if $isLand {set terrain COAST}
		set movement $waterMovement
	} else {
		set movement {}
	}

	# A dictionary sort is case-insensitive.
	geographyTable addRow $terrain $located [lsort -dictionary $movement]
}
geographyTable write $g
itcl::delete object geographyTable

puts $g "\n# Politics\n"

foreach space [lsort [array names territoryType]] {
	set primary [string index $territoryType($space) 0]
	if [string equal $primary "x"] {
		lappend supplies $space
	} elseif {![string is lower $primary]} {
		if {![info exists inpower($primary)]} {
			warn "No power exists with the initial $primary for which $space is a home center"
		} else {
			lappend homes($inpower($primary)) $space
		}
	}
}

Table powerTable "%s %s %s"
foreach power $powers {
	set naming {}
	if {![string equal $power $adjective($power)]} {append naming $adjective($power)}
	if {![string equal [string index $power 0] $initial($power)]} {append naming ":$initial($power)"}
	if [string length $naming] {
		set naming "($naming)"
	}
	if [info exists homes($power)] {
		powerTable addRow $power $naming $homes($power)
	} else {
		powerTable addRow $power $naming {}
	}
}
if [info exists supplies] {
	set widths [powerTable getWidths]
	set width [expr (([lindex $widths 0] >= [string length UNOWNED]) ? [lindex $widths 0] : [string length UNOWNED]) + 1 + ([lindex $widths 1] ? ([lindex $widths 1] + 1) : 0)]
	if {$width < 80 - $width} {set width [expr 80 - $width]}
	if {$width < [lindex $widths 2]} {set width [lindex $widths 2]}
	if {[string length $supplies] <= $width} {
		powerTable addRow UNOWNED {} $supplies
	} else {
		set length -1
		set supplying {}
		foreach supply $supplies {
			if {$length + ([string length $supply] + 1) <= $width} {
				lappend supplying $supply
				incr length [expr [string length $supply] + 1]
			} else {
				powerTable addRow UNOWNED {} $supplying
				set supplying $supply
				set length [string length $supply]
			}
		}
		powerTable addRow UNOWNED {} $supplying
	}
}
powerTable write $g
itcl::delete object powerTable

puts $g "\n# Military"

foreach power $powers {

	set unwritten 1

	if [info exists centers($power)] {
		if [info exists homes($power)] {set free $homes($power)} else {set free {}}
		set nrHomes [llength $free]
		set taken {}
		foreach center $centers($power) {
			set center [findAlternative $center "Initial center" $power]
			lappend taken $center
			if {[set idx [lsearch $free $center]] != -1} {set free [lreplace $free $idx $idx]} 
		}
		if {[llength $free] || ([llength $taken] != $nrHomes)} {
			puts $g "\n$power\nOWNS $taken"
			set unwritten 0
		}
	} elseif {[info exists homes($power)] && [llength $homes($power)]} {
		# Owns nothing at the start
		puts $g "\n$power\nOWNS"
		set unwritten 0
	}

	if [info exists units($power)] {
		if $unwritten {puts $g "\n$power"}
		foreach {unitType space} $units($power) {
			puts $g [list $unitType [findMain $space "Starting place of unit $unitType" $power]]
		} 
	}
}

if [info exists rules] {
	puts $g "\n# Rules\n"
	foreach rule $rules {
		puts $g $rule
	}
}

puts $g "\n# End of DPjudge map data"

close $g
